home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
akcl
/
kcl.lha
/
lsp
/
trace.lsp
< prev
Wrap
Lisp/Scheme
|
1987-06-04
|
9KB
|
259 lines
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; trace.lsp
;;;;
;;;; Tracer package for Common Lisp
(in-package 'lisp)
(export '(trace untrace))
(export 'step)
(in-package 'system)
(proclaim '(optimize (safety 2) (space 3)))
(defvar *trace-level* 0)
(defvar *trace-list* nil)
(defmacro trace (&rest r)
(if (null r)
'*trace-list*
`(mapcan #'trace-one ',r)))
(defmacro untrace (&rest r)
(if (null r)
'(mapcan #'untrace-one *trace-list*)
`(mapcan #'untrace-one ',r)))
(defun trace-one (fname &aux f)
(when (null (fboundp fname))
(format *trace-output* "The function ~S is not defined.~%" fname)
(return-from trace-one nil))
(when (special-form-p fname)
(format *trace-output* "~S is a special form.~%" fname)
(return-from trace-one nil))
(when (macro-function fname)
(format *trace-output* "~S is a macro.~%" fname)
(return-from trace-one nil))
(when (get fname 'traced)
(cond ((and (consp (symbol-function fname))
(consp (nth 3 (symbol-function fname)))
(eq (car (nth 3 (symbol-function fname))) 'trace-call))
(format *trace-output*
"The function ~S is already traced.~%" fname)
(return-from trace-one nil))
(t (untrace-one fname))))
(si:fset (setq f (gensym)) (symbol-function fname))
(si:putprop fname f 'traced)
(eval `(defun ,fname (&rest args) (trace-call ',fname ',f args)))
(setq *trace-list* (cons fname *trace-list*))
(list fname))
(defun trace-call (fname temp-name args
&aux (*trace-level* *trace-level*) values indent)
(setq *trace-level* (1+ *trace-level*))
(setq indent (min (* *trace-level* 2) 20))
(fresh-line *trace-output*)
(format *trace-output*
"~V@T~D> ~S~%"
indent *trace-level* (cons fname args))
(setq values (multiple-value-list (apply temp-name args)))
(fresh-line *trace-output*)
(format *trace-output*
"~V@T<~D ~S~%"
indent
*trace-level*
(cons fname values))
(setq *trace-level* (1- *trace-level*))
(values-list values))
(defun untrace-one (fname)
(cond ((get fname 'traced)
(if (and (consp (symbol-function fname))
(consp (nth 3 (symbol-function fname)))
(eq (car (nth 3 (symbol-function fname))) 'trace-call)
; (LAMBDA-BLOCK block-name lambda-list (TRACE-CALL ... ))
)
(si:fset fname (symbol-function (get fname 'traced)))
(format *trace-output*
"The function ~S was traced, but redefined.~%"
fname))
(remprop fname 'traced)
(setq *trace-list* (list-delq fname *trace-list*))
(list fname))
(t
(format *trace-output* "The function ~S is not traced.~%" fname)
nil)))
(defvar *step-level* 0)
(defvar *step-quit* nil)
(defvar *step-function* nil)
(defvar *old-print-level* nil)
(defvar *old-print-length* nil)
(defun step-read-line ()
(do ((char (read-char *debug-io*) (read-char *debug-io*)))
((or (char= char #\Newline) (char= char #\Return)))))
(defmacro if-error (error-form form)
(let ((v (gensym)) (f (gensym)) (b (gensym)))
`(let (,v ,f)
(block ,b
(unwind-protect (setq ,v ,form ,f t)
(return-from ,b (if ,f ,v ,error-form)))))))
(defmacro step (form)
`(let* ((*old-print-level* *print-level*)
(*old-print-length* *print-length*)
(*print-level* 2)
(*print-length* 2))
(read-line)
(format *debug-io* "Type ? and a newline for help.~%")
(setq *step-quit* nil)
(stepper ',form nil)))
(defun stepper (form &optional env
&aux values (*step-level* *step-level*) indent)
(when (eq *step-quit* t)
(return-from stepper (evalhook form nil nil env)))
(when (numberp *step-quit*)
(if (>= (1+ *step-level*) *step-quit*)
(return-from stepper (evalhook form nil nil env))
(setq *step-quit* nil)))
(when *step-function*
(if (and (consp form) (eq (car form) *step-function*))
(let ((*step-function* nil))
(return-from stepper (stepper form env)))
(return-from stepper (evalhook form #'stepper nil env))))
(setq *step-level* (1+ *step-level*))
(setq indent (min (* *step-level* 2) 20))
(loop
(format *debug-io* "~VT~S " indent form)
(finish-output *debug-io*)
(case (do ((char (read-char *debug-io*) (read-char *debug-io*)))
((and (char/= char #\Space) (char/= char #\Tab)) char))
((#\Newline #\Return)
(setq values
(multiple-value-list
(evalhook form #'stepper nil env)))
(return))
((#\n #\N)
(step-read-line)
(setq values
(multiple-value-list
(evalhook form #'stepper nil env)))
(return))
((#\s #\S)
(step-read-line)
(setq values
(multiple-value-list
(evalhook form nil nil env)))
(return))
((#\p #\P)
(step-read-line)
(write form
:stream *debug-io*
:pretty t :level nil :length nil)
(terpri))
((#\f #\F)
(let ((*step-function*
(if-error nil
(prog1 (read-preserving-whitespace *debug-io*)
(step-read-line)))))
(setq values
(multiple-value-list
(evalhook form #'stepper nil env)))
(return)))
((#\q #\Q)
(step-read-line)
(setq *step-quit* t)
(setq values
(multiple-value-list
(evalhook form nil nil env)))
(return))
((#\u #\U)
(step-read-line)
(setq *step-quit* *step-level*)
(setq values
(multiple-value-list
(evalhook form nil nil env)))
(return))
((#\e #\E)
(let ((env1 env))
(dolist (x
(if-error nil
(multiple-value-list
(evalhook
(if-error nil
(prog1
(read-preserving-whitespace
*debug-io*)
(step-read-line)))
nil nil env1))))
(write x
:stream *debug-io*
:level *old-print-level*
:length *old-print-length*)
(terpri *debug-io*))))
((#\r #\R)
(let ((env1 env))
(setq values
(if-error nil
(multiple-value-list
(evalhook
(if-error nil
(prog1
(read-preserving-whitespace
*debug-io*)
(step-read-line)))
nil nil env1)))))
(return))
((#\b #\B)
(step-read-line)
(let ((*ihs-base* (1+ *ihs-top*))
(*ihs-top* (1- (ihs-top)))
(*current-ihs* *ihs-top*))
(backtrace)))
(t
(step-read-line)
(terpri)
(format *debug-io*
"Stepper commands:~%~
n (or N or Newline): advances to the next form.~%~
s (or S): skips the form.~%~
p (or P): pretty-prints the form.~%~
f (or F) FUNCTION: skips until the FUNCTION is called.~%~
q (or Q): quits.~%~
u (or U): goes up to the enclosing form.~%~
e (or E) FORM: evaluates the FORM ~
and prints the value(s).~%~
r (or R) FORM: evaluates the FORM ~
and returns the value(s).~%~
b (or B): prints backtrace.~%~
?: prints this.~%")
(terpri))))
(when (or (constantp form) (and (consp form) (eq (car form) 'quote)))
(return-from stepper (car values)))
(if (endp values)
(format *debug-io* "~V@T=~%" indent)
(do ((l values (cdr l))
(b t nil))
((endp l))
(if b
(format *debug-io* "~V@T= ~S~%" indent (car l))
(format *debug-io* "~V@T& ~S~%" indent (car l)))))
(setq *step-level* (- *step-level* 1))
(values-list values))